import Data.List
import Data.Maybe
import Data.List.Split
import Debug.Trace

data Cell = Cell { value::Int
                 , address::(Int, Int)
                 , possibilities::[Int]
                 }
                 
instance Show Cell where
    show (Cell v (r,c) ps) = "Cell[" ++ sr ++ "," ++ sc ++ "] = " ++ sv ++ " {" ++ sx ++"}\n"
        where sr = show r
              sc = show c
              sv = show v
              sx = unwords $ map show ps
              
isEmpty :: Cell -> Bool
isEmpty (Cell v _ _) = v == 0
                    
attributeList :: [Cell] -> (Cell -> a) -> [a]
attributeList xs f = map f xs

listValues :: [Cell] -> [Int]
listValues xs = attributeList xs value

listValues0 :: [Cell] -> [Int]
listValues0 xs = filter (>0) (listValues xs)

listAddresses :: [Cell] -> [(Int,Int)]
listAddresses xs = attributeList xs address

listPossibilities :: [Cell] -> [[Int]]
listPossibilities xs = attributeList xs possibilities
                    
cells :: Eq a => [Cell] -> (Cell -> a) -> a -> [Cell]
cells []     _ _ = []
cells (x:xs) f y = if f x == y then e else n
    where e = x : n
          n = cells xs f y
          
row :: [Cell] -> Int -> [Cell]
row xs y = cells xs (fst . address) y

column :: [Cell] -> Int -> [Cell]
column xs y = cells xs (snd . address) y

block :: [Cell] -> (Int,Int) -> [Cell]
block xs (r,c) = map (head . (cells xs address)) ds
    where rs = block' r
          cs = block' c
          ds = [(x,y) | x <- rs, y <- cs]
    
block' :: Int -> [Int]
block' n
    | n >= 0 && n <= 2 = [0,1,2]
    | n >= 3 && n <= 5 = [3,4,5]
    | n >= 6 && n <= 8 = [6,7,8]
    
used :: [Cell] -> Cell -> [Int]
used xs y = ((filter (>0)) . sort . nub) $ (value y) : (rs `union` cs `union` bs)
    where ad = address y
          rw = fst ad
          cl = snd ad
          rs = listValues0 $ row xs rw
          cs = listValues0 $ column xs cl
          bs = listValues0 $ block xs (rw,cl)  

fillValue :: Cell -> Cell
fillvalue c@(Cell x y ps) = if isEmpty c then new else c
    where new = Cell (head ps) y (tail ps)
    
fillAllPossibleValues :: [Cell] -> [Cell]
fillAllPossibleValues xs = map (fillPossibleValues xs) xs
    
fillPossibleValues :: [Cell] -> Cell -> Cell
fillPossibleValues xs y = if isEmpty y then new else y
    where ps = (\\) [1..9] (used xs y)
          new = Cell (value y) (address y) ps    
          
isSingleton :: [a] -> Bool
isSingleton [a] = True
isSingleton _   = False          
          
fillAllSinglePossibilities :: [Cell] -> [Cell]
fillAllSinglePossibilities xs = map (fillSinglePossibilities xs) xs          
         
fillSinglePossibilities :: [Cell] -> Cell -> Cell
fillSinglePossibilities xs y@(Cell v a ps) = if con then new else y
    where con = (isEmpty y) && (isSingleton ps)
          new = Cell (head ps) a []
          
guessOne :: [Cell] -> [Cell]
guessOne [] = []
guessOne (x@(Cell v a ps):xs) = if null ps then x : guessOne xs else new : xs
    where new = (Cell (head ps) a (tail ps))
          
solve :: [Cell] -> [Cell]
solve xs = trace (showValues xs) (if needExit then xs else if mustApplyAgain then if needGuessing then solve nextWithGuess else solve next else next)
    where next = (fillAllSinglePossibilities . fillAllPossibleValues) xs
          mustApplyAgain = (count0 next) > 0
          count0 = length . (filter (==0)) . listValues
          needGuessing = (count0 next) == (count0 xs)
          nextWithGuess = guessOne next
          needExit = (count0 nextWithGuess) == (count0 xs)
          
                                              
showCells :: [Cell] -> IO()
showCells xs = putStr $ concat $ map show xs            
          
toMatrix :: [String] -> String
toMatrix = unlines . (map unwords) . (chunksOf 9)    
          
showCellsWith :: Show a => [Cell] -> (Cell -> a) -> IO ()
showCellsWith xs f = putStr $ toMatrix $ map (show . f) xs

showValues :: [Cell] -> String
showValues = toMatrix . (map show) . listValues

showAddresses :: [Cell] -> IO ()
showAddresses = putStr . toMatrix . (map show) . listAddresses

createCells'' :: [Int] -> (Int,Int) -> [Cell]
createCells'' []     (r,c) = []
createCells'' (x:xs) (r,c) = (Cell x (r,c) []) : createCells'' xs (r,c+1)

createCells' :: [[Int]] -> (Int,Int) -> [[Cell]]
createCells' []     (r,c) = []
createCells' (x:xs) (r,c) = cs : createCells' xs (r+1,c) 
    where cs = createCells'' x (r,c)
        
createCells :: [[Int]] -> [Cell]
createCells xs = concat $ createCells' xs (0,0)    

main = do
    f <- readFile "d:\\sudoku.txt"
    let ls = map words $ lines f
        cs = createCells $ map (map read) ls
        solved = showValues $ solve cs
    writeFile "d:\\solution.txt" solved
    
s = [[5,3,6,8,0,7,0,0,0]
    ,[9,0,4,0,5,1,8,3,7]
    ,[0,0,0,9,4,0,0,0,6]
    ,[0,0,0,0,0,0,2,4,0]
    ,[0,9,0,0,0,0,0,7,0]
    ,[0,8,5,0,0,0,0,0,0]
    ,[6,0,0,0,1,8,0,0,0]
    ,[1,5,3,2,9,0,7,0,4]
    ,[0,0,0,7,0,5,6,1,9]] :: [[Int]]